;;;evall for functional LISP terms

(defun evall (e a) 
  (cond ((atom e) 
	  (cond ((numberp e) e) 
		((eq e T) e)
		((eq e NIL) e)
		(T (cdr (assoc e a)))))
	((atom (car e))
	  (cond ((eq (car e) 'QUOTE) (cadr e))
		((eq (car e)  'COND) (evcond (cdr e) a))
		((eq (car e)  'LIST) (evlist (cdr e) a))
		((eq (car e)   'CAR) (car (evall (cadr e) a)))
		((eq (car e)   'CDR) (cdr (evall (cadr e) a)))
		((eq (car e)   'CAAR) (caar (evall (cadr e) a)))
		((eq (car e)   'CADR) (cadr (evall (cadr e) a)))
		((eq (car e)   'CADDR) (caddr (evall (cadr e) a)))
		((eq (car e)   'CADAR) (cadar (evall (cadr e) a)))
		((eq (car e)   'CADDAR) (caddar (evall (cadr e) a)))
		((eq (car e)  'CONS) (cons (evall (cadr e) a) (evall (caddr e) a)))
		((eq (car e)  'ATOM) (atom (evall (cadr e) a)))
		((eq (car e)  'NULL) (null (evall (cadr e) a)))
		((eq (car e) 'NUMBERP) (numberp (evall (cadr e) a)))

		((eq (car e)    'EQ) (eq (evall (cadr e) a) (evall (caddr e) a)))
		(T 
;;;tracing evall evcond evlist
;;;	      	  (cond ((memq (car e) '(evall evcond evlist)) (print e)))
		  (evall (cons (cdr (assoc (car e) a)) (cdr e)) a))))
	(T
	  (cond ((eq (caar e) 'LAMBDA) 
		  (evall (caddar e) (prup (cadar e) (evlist (cdr e) a) a)))
	        ((eq (caar e) 'LABEL) 
		  (evall (cons (caddar e) (cdr e)) 
			(cons (cons (cadar e) (caddar e)) a)))))))

(defun evcond (u a)
  (cond ((null u) NIL)
	((evall (caar u) a) (evall (cadar u) a))
	(T (evcond (cdr u) a))))

(defun evlist (u a)
  (cond ((null u) NIL)
	(T (cons (evall (car u) a) (evlist (cdr u) a)))))

(defun prup (u v a)
  (cond ((null u) a)
	(T (prup (cdr u) (cdr v) (cons (cons (car u) (car v)) a)))))

(defun assoc (x u)
  (cond ((null u) NIL)
	((eq (caar u) x) (car u))
	(T (assoc x (cdr u)))))


(defun ff (x)
  (cond ((atom x) x) (T (ff (car x)))))

;;;evall alist initialization

(prog ()

(setq λevall 
'(lambda (e a)
  (cond ((atom e) 
	  (cond ((numberp e) e) 
		((eq e T) e)
		((eq e NIL) e)
		(T (cdr (assoc e a)))))
	((atom (car e))
	  (cond ((eq (car e) 'QUOTE) (cadr e))
		((eq (car e)  'COND) (evcond (cdr e) a))
		((eq (car e)  'LIST) (evlist (cdr e) a))
		((eq (car e)   'CAR) (car (evall (cadr e) a)))
		((eq (car e)   'CDR) (cdr (evall (cadr e) a)))
		((eq (car e)   'CAAR) (caar (evall (cadr e) a)))
		((eq (car e)   'CADR) (cadr (evall (cadr e) a)))
		((eq (car e)   'CADDR) (caddr (evall (cadr e) a)))
		((eq (car e)   'CADAR) (cadar (evall (cadr e) a)))
		((eq (car e)   'CADDAR) (caddar (evall (cadr e) a)))
		((eq (car e)  'CONS) (cons (evall (cadr e) a) (evall (caddr e) a)))
		((eq (car e)  'ATOM) (atom (evall (cadr e) a)))
		((eq (car e)  'NULL) (null (evall (cadr e) a)))
		((eq (car e) 'NUMBERP) (numberp (evall (cadr e) a)))
		((eq (car e)    'EQ) (eq (evall (cadr e) a) (evall (caddr e) a)))
		(T (evall (cons (cdr (assoc (car e) a)) (cdr e)) a))))
	(T
	  (cond ((eq (caar e) 'LAMBDA) 
		  (evall (caddar e) (prup (cadar e) (evlist (cdr e) a) a)))
	        ((eq (caar e) 'LABEL) 
		  (evall (cons (caddar e) (cdr e)) 
			(cons (cons (cadar e) (caddar e)) a)))))))
)


(setq λevcond
'(lambda (u a)
  (cond ((null u) NIL)
	((evall (caar u) a) (evall (cadar u) a))
	(T (evcond (cdr u) a))))
)

(setq λevlist
'(lambda (u a)
  (cond ((null u) NIL)
	(T (cons (evall (car u) a) (evlist (cdr u) a)))))
)


(setq λprup
'(lambda (u v a)
  (cond ((null u) a)
	(T (prup (cdr u) (cdr v) (cons (cons (car u) (car v)) a)))))
)


(setq λassoc
'(lambda (x u)
  (cond ((null u) NIL)
	((eq (caar u) x) (car u))
	(T (assoc x (cdr u)))))
)


(setq λff
'(lambda (x)
  (cond ((atom x) x) (T (ff (car x)))))
)

(setq  a (list  (cons 'evall λevall)
                (cons 'evcond λevcond)
                (cons 'evlist λevlist)
                (cons 'prup λprup)
                (cons 'assoc λassoc)
))

(setq  aa (list (cons 'ff λff)))

(return 'evall-alist-inited)
)

;;;← (evall '(evall '(ff 1) aa) (cons (cons 'aa aa) a))
;;;
;;;(EVALL (QUOTE (FF 1)) AA) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVALL (CADAR U) A) 
;;;1 
;;;← (evall '(evall '(ff '(baz)) aa) (cons (cons 'aa aa) a))
;;;
;;;(EVALL (QUOTE (FF (QUOTE (BAZ)))) AA) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVCOND (CDR U) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADAR U) A) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVALL (CADAR U) A) 
;;;BAZ 
;;;← 
;;;← (evall '(evall '(ff '((bar.baz))) aa) (cons (cons 'aa aa) a))
;;;
;;;(EVALL (QUOTE (FF (QUOTE ((BAR . BAZ))))) AA) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVCOND (CDR U) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADAR U) A) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVCOND (CDR U) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADAR U) A) 
;;;(EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A) 
;;;(EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)) 
;;;(EVLIST (CDR E) A) 
;;;(EVALL (CAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVLIST (CDR U) A) 
;;;(EVCOND (CDR E) A) 
;;;(EVALL (CAAR U) A) 
;;;(EVALL (CADR E) A) 
;;;(EVALL (CADAR U) A) 
;;;BAR 
;;;←